home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / modboot.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  15KB  |  545 lines
  1. /* ******************************************************************** */
  2. /*  modboot.c        Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  Wild thing II                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modboot.c,v 1.9 1992/03/13 18:12:02 pab Exp $
  9.  *
  10.  * $Log: modboot.c,v $
  11.  * Revision 1.9  1992/03/13  18:12:02  pab
  12.  * sysV fix: move value vectors into shared space
  13.  * so GC can get to them.
  14.  *
  15.  * Revision 1.8  1992/01/29  13:42:45  pab
  16.  * binding fixes
  17.  *
  18.  * Revision 1.7  1992/01/09  22:28:55  pab
  19.  * Fixed for low tag ints
  20.  *
  21.  * Revision 1.6  1992/01/07  22:15:44  pab
  22.  * ncc compatable, plus backtrace
  23.  *
  24.  * Revision 1.5  1992/01/07  17:12:29  pab
  25.  * Added a cast. No sign of the stardent bug
  26.  *
  27.  * Revision 1.4  1992/01/05  22:48:09  pab
  28.  * Minor bug fixes, plus BSD version
  29.  *
  30.  * Revision 1.3  1991/12/22  15:14:19  pab
  31.  * Xmas revision
  32.  *
  33.  * Revision 1.2  1991/09/11  12:07:25  pab
  34.  * 11/9/91 First Alpha release of modified system
  35.  *
  36.  * Revision 1.1  1991/08/12  16:49:47  pab
  37.  * Initial revision
  38.  *
  39.  * Revision 1.4  1991/06/04  17:17:21  kjp
  40.  * No acceptable change.
  41.  *
  42.  * Revision 1.3  1991/02/13  18:23:36  kjp
  43.  * Pass.
  44.  *
  45.  */
  46.  
  47. #include <stdio.h>
  48. #include <string.h>
  49. #include <ctype.h>
  50.  
  51. #include "funcalls.h"
  52. #include "defs.h"
  53. #include "structs.h"
  54. #include "global.h"
  55. #include "defs.h"
  56.  
  57. #include "allocate.h"
  58. #include "symboot.h"
  59.  
  60. #include "ngenerics.h"
  61. #include "modules.h"
  62.  
  63. #include "table.h"
  64. #include "error.h"
  65.  
  66. #include "modboot.h"
  67.  
  68. /* Current module information */
  69.  
  70. MODULE*  current_open_module; /* The thing itself */
  71. static int      entries;     /* No of entries it claims to have */
  72. static int      entry_count; /* The no of entries thus far */
  73.  
  74. /* Are we generating .i files... */
  75.  
  76. extern int command_line_interface_flag;
  77. #define CREATE_INTERFACE (command_line_interface_flag)
  78.  
  79. /* Interface generators... */
  80.  
  81. static FILE *i_file;
  82.  
  83. static void open_module_interface(char *name)
  84. {
  85.   char i_name[500];
  86.  
  87.   sprintf(i_name,"%s%s",MODULE_PATH,"../KerInterfaces/");
  88.  
  89.   strcat(i_name,name);
  90.   strcat(i_name,".i");
  91.  
  92.   i_file = fopen(i_name,"w");
  93.  
  94.   fprintf(i_file,"((dependencies)\n (exported-ids ");
  95.   fflush(i_file);
  96.   printf("Open %s - ",name); fflush(stdout);
  97. }
  98.  
  99. static void update_interface(char *name,int index,int argtype)
  100. {
  101.   fprintf(i_file,"\n   ((name . |%s|) (address %s . %d) (class . function) (argtype . %d))",
  102.       name,current_open_module->name->SYMBOL.pname,index,argtype);
  103.   fflush(i_file);
  104. }
  105.  
  106. static void close_module_interface()
  107. {
  108.   printf("closing - "); fflush(stdout);
  109.   fprintf(i_file,"))\n");
  110.   fflush(i_file);
  111.   fclose(i_file);
  112.   printf("closed\n"); fflush(stdout);
  113. }
  114.  
  115. void open_module(LispObject *stacktop, MODULE* mod,LispObject *vals,char* name,int ents)
  116. {
  117.   if (current_open_module != NULL) {
  118.     fprintf(stderr,"\nINITERROR: tried to open '%s' while in '%s'\n",
  119.                name,current_open_module->name);
  120.     system_lisp_exit(1);
  121.   }
  122.  
  123.   /* Set up the fresh module */
  124.   STACK_TMP((LispObject)mod);
  125.   mod->values = (LispObject *) allocate_space(stacktop,ents*sizeof(LispObject));
  126.   mod->functions = (LispObject (**)()) malloc(ents*sizeof(LispObject (*)()));
  127.   
  128.   lval_typeof((LispObject) mod) = TYPE_C_MODULE;
  129.   gcof((LispObject) mod) = 0;
  130.   lval_classof((LispObject) mod) = Object;
  131.  
  132.   mod->name = get_symbol(stacktop,name);
  133.  
  134.   put_module(stacktop,mod->name,(LispObject) mod); 
  135.  
  136.   mod->imported_modules = nil;
  137.   mod->bindings = (LispObject) allocate_table(stacktop,Fn_eq);
  138.   mod->exported_names = nil;
  139.   mod->entry_count = ents;
  140.  
  141.   /* Set up tracking info */
  142.  
  143.   current_open_module = mod;
  144.   entries = ents;
  145.   entry_count = 0;
  146.   
  147.   /* Interface... */
  148.  
  149.   if (CREATE_INTERFACE) open_module_interface(name);
  150. }
  151.  
  152. LispObject make_module_function(LispObject *stacktop,char* lispname,
  153.                 LispObject (*fun)(LispObject*),int argcode)
  154. {
  155.   LispObject lfunc;
  156.   LispObject symbol,number;
  157.  
  158.   if (entry_count == entries) {
  159.     fprintf(stderr,
  160.         "\nINITERROR: more module functions that declared in '%s'\n",
  161.         current_open_module->name->SYMBOL.pname);
  162.     exit(1);
  163.   }
  164.  
  165.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  166.   STACK_TMP(symbol);
  167.  
  168.   (current_open_module->values)[entry_count] = 
  169.     allocate_module_function(stacktop,(LispObject)current_open_module,
  170.                  symbol,fun,argcode);
  171.   (current_open_module->functions)[entry_count] = fun;
  172.   number=allocate_integer(stacktop,entry_count);
  173.   UNSTACK_TMP(symbol);
  174.   /* GC Safe */
  175.  
  176.   ADD_BINDING(current_open_module,symbol,number,nil);
  177.  
  178.   current_open_module->exported_names = 
  179.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  180.  
  181.   if (CREATE_INTERFACE) update_interface(lispname,entry_count,argcode);
  182.   ++entry_count;
  183.  
  184.   return(current_open_module->values[entry_count-1]);
  185. }
  186.  
  187. LispObject make_unexported_module_function(LispObject *stacktop,char* lispname,
  188.                        LispObject (*fun)(),int argcode)
  189. {
  190.   LispObject lfunc;
  191.   LispObject symbol,number;
  192.  
  193.   if (entry_count == entries) {
  194.     fprintf(stderr,
  195.         "\nINITERROR: more module functions that declared in '%s'\n",
  196.         current_open_module->name->SYMBOL.pname);
  197.     exit(1);
  198.   }
  199.  
  200.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  201.  
  202.   STACK_TMP(symbol);
  203.   (current_open_module->values)[entry_count] = 
  204.     allocate_module_function(stacktop,(LispObject)current_open_module,
  205.                  symbol,fun,argcode);
  206.   (current_open_module->functions)[entry_count] = NULL;
  207.   number=allocate_integer(stacktop,entry_count);
  208.   UNSTACK_TMP(symbol);
  209.  
  210.   ADD_BINDING(current_open_module,symbol,number,nil);
  211.  
  212.  
  213.   /* Symbols can't be GC'd and modules are safe anyway!! */
  214.  
  215.   ++entry_count;
  216.  
  217. /*  fprintf(stderr,"%d OK\n",entry_count); fflush(stderr); */
  218.  
  219.   return((current_open_module->values)[entry_count-1]);
  220. }
  221.  
  222. LispObject make_module_macro(LispObject *stacktop,char *name,LispObject (*func)(),int args)
  223. {
  224.   LispObject ret;
  225.  
  226.   ret = make_module_function(stacktop,name,func,args);
  227.   lval_typeof(ret) = TYPE_C_MACRO;
  228.  
  229.   return(ret);
  230. }
  231.  
  232. void close_module()
  233. {
  234.   if (current_open_module == NULL) {
  235.     fprintf(stderr,"\nINITERROR: tried to close NULL module\n");
  236.     exit(1);
  237.   }
  238.  
  239.   if (entries != entry_count) {
  240.     fprintf(stderr,
  241.         "\nINITERROR: tried to close '%s' with %d entries, %d needed\n",
  242.         current_open_module->name->SYMBOL.pname,entry_count,entries);
  243.     exit(1);
  244.   }
  245.  
  246.   current_open_module = NULL;
  247.   if (CREATE_INTERFACE) close_module_interface();
  248. }
  249.  
  250.  
  251. LispObject make_unexported_module_special(LispObject *stacktop,char* lispname,LispObject (*fun)())
  252. {
  253.   LispObject number;
  254.   LispObject symbol;
  255.  
  256.   if (entry_count == entries) {
  257.     fprintf(stderr,
  258.         "\nINITERROR: more module functions that declared in '%s'\n",
  259.         current_open_module->name->SYMBOL.pname);
  260.     exit(1);
  261.   }
  262.  
  263.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  264.  
  265.   STACK_TMP(symbol);
  266.   (current_open_module->values)[entry_count] = allocate_special(stacktop,symbol,fun);
  267.   number=allocate_integer(stacktop,entry_count);
  268.   UNSTACK_TMP(symbol);
  269.   
  270.   ADD_BINDING(current_open_module,symbol,number,nil);
  271.  
  272.   /* Symbols can't be GC'd and modules are safe anyway!! */
  273.  
  274.   ++entry_count;
  275.  
  276.   return((current_open_module->values)[entry_count-1]);
  277. }
  278.  
  279. LispObject make_module_entry(LispObject *stacktop,char *name,LispObject value)
  280. {
  281.   LispObject symbol,number;
  282.  
  283.   if (entry_count == entries) {
  284.     fprintf(stderr,
  285.         "\nINITERROR: more module entries that declared in '%s'\n",
  286.         current_open_module->name->SYMBOL.pname);
  287.     exit(1);
  288.   }
  289.   (current_open_module->values)[entry_count] = value; 
  290.   (current_open_module->functions)[entry_count] = NULL;
  291.  
  292.   STACK_TMP(value);
  293.   symbol = get_symbol(stacktop,name); /* May or may not allocate anew */
  294.   STACK_TMP(symbol);
  295.   number = allocate_integer(stacktop,entry_count);
  296.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  297.  
  298.   ADD_BINDING(current_open_module,symbol,number,nil);
  299.  
  300.   
  301.   UNSTACK_TMP(symbol);
  302.  
  303.   number =
  304.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  305.   current_open_module->exported_names = number;
  306.  
  307.   if (CREATE_INTERFACE) update_interface(name,entry_count,-1);
  308.   ++entry_count;
  309.  
  310.   UNSTACK_TMP(value);
  311.   return(value);
  312. }
  313.  
  314.  
  315. LispObject make_module_entry_using_symbol(LispObject *stacktop,
  316.                       LispObject symbol,LispObject value)
  317. {
  318.   LispObject number;
  319.   if (entry_count == entries) {
  320.     fprintf(stderr,
  321.         "\nINITERROR: more module entries that declared in '%s'\n",
  322.         current_open_module->name->SYMBOL.pname);
  323.     exit(1);
  324.   }
  325.   
  326.  
  327.   (current_open_module->values)[entry_count] = value; 
  328.   (current_open_module->functions)[entry_count] = NULL;
  329.  
  330.   STACK_TMP(value); STACK_TMP(symbol);
  331.   number = allocate_integer(stacktop,entry_count);
  332.   ADD_BINDING(current_open_module,symbol,number,nil);
  333.  
  334.   UNSTACK_TMP(symbol); STACK_TMP(symbol);
  335.   current_open_module->exported_names = 
  336.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  337.   UNSTACK_TMP(symbol);
  338.  
  339.   if (CREATE_INTERFACE) update_interface(symbol->SYMBOL.pname,entry_count,-1);
  340.   ++entry_count;
  341.   UNSTACK_TMP(value);
  342.   return(value);
  343. }
  344.  
  345. LispObject make_module_special(LispObject *stacktop,
  346.                    char* lispname,LispObject (*fun)())
  347. {
  348.   LispObject lfunc;
  349.   LispObject symbol,number;
  350.  
  351.   if (entry_count == entries) {
  352.     fprintf(stderr,
  353.         "\nINITERROR: more module functions that declared in '%s'\n",
  354.         current_open_module->name->SYMBOL.pname);
  355.     exit(1);
  356.   }
  357.  
  358.   symbol = get_symbol(stacktop,lispname); /* May or may not allocate anew */
  359.   STACK_TMP(symbol);
  360.   (current_open_module->values)[entry_count] = 
  361.     (LispObject) allocate_special(stacktop,symbol,fun);
  362.   (current_open_module->functions)[entry_count] = NULL;
  363.   number = allocate_integer(stacktop,entry_count);
  364.   UNSTACK_TMP(symbol);
  365.   STACK_TMP(symbol);
  366.  
  367.   UNSTACK_TMP(symbol);
  368.   /* Symbols can't be GC'd and modules are safe anyway!! */
  369.   ADD_BINDING(current_open_module,symbol,number,nil);
  370.  
  371.   current_open_module->exported_names = 
  372.     EUCALL_2(Fn_cons,symbol,current_open_module->exported_names);
  373.  
  374.   ++entry_count;
  375.  
  376.   return((current_open_module->values)[entry_count-1]);
  377. }
  378.  
  379. LispObject make_module_generic(LispObject *stackbase,char *name,int code)
  380. {
  381.   LispObject sym,number,tmp;
  382.   LispObject *stacktop=stackbase+1,*gf=stackbase;
  383.   if (entry_count == entries) {
  384.     fprintf(stderr,
  385.         "\nINITERROR: more module functions that declared in '%s'\n",
  386.         current_open_module->name->SYMBOL.pname);
  387.     exit(1);
  388.   }
  389.  
  390.   *gf=nil;
  391.   current_open_module->values[entry_count] =
  392.     allocate_instance(stacktop,Generic);
  393.  
  394.   *gf=current_open_module->values[entry_count];
  395.   generic_home(*gf) = (LispObject)current_open_module;
  396.   lval_typeof(*gf)=TYPE_GENERIC;
  397.  
  398.   sym = get_symbol(stacktop,name);
  399.   STACK_TMP(sym);
  400.   tmp = allocate_integer(stacktop,code);
  401.   generic_argtype(*gf)=tmp;
  402.   number=allocate_integer(stacktop,entry_count);
  403.   UNSTACK_TMP(sym);
  404.  
  405.   STACK_TMP(number); STACK_TMP(sym);
  406.   generic_name(*gf) = sym;
  407.  
  408.   generic_discriminator(*gf) = nil;
  409.   generic_slow_method_cache(*gf) = nil;
  410.   generic_fast_method_cache(*gf) = nil;
  411.   generic_method_table(*gf) = nil;
  412.   
  413.   generic_method_class(*gf) = Method;
  414.   
  415.   (current_open_module->functions)[entry_count] = NULL;
  416.   UNSTACK_TMP(sym); UNSTACK_TMP(number);
  417.   STACK_TMP(sym);
  418.  
  419.   ADD_BINDING(current_open_module,sym,number,nil);
  420.   UNSTACK_TMP(sym);
  421.   /* Symbols can't be GC'd and modules are safe anyway!! */
  422.  
  423.   current_open_module->exported_names = 
  424.     EUCALL_2(Fn_cons,sym,current_open_module->exported_names);
  425.  
  426.   if (CREATE_INTERFACE) update_interface(name,entry_count,code);
  427.   ++entry_count;
  428.  
  429.   return(*gf);
  430. }
  431.  
  432. LispObject make_wrapped_module_generic(LispObject *stacktop,char *name,int code,
  433.                        LispObject (*fun)())
  434. {
  435.   LispObject number;
  436.   LispObject sym,gf,tmp;
  437.   LispObject *stackbase=stacktop;
  438.  
  439.   ARG_0(stackbase) = nil; /*gf*/
  440.   ARG_1(stackbase)=nil; /* number*/
  441.   ARG_2(stackbase)=nil; /*sym*/
  442.  
  443.   stacktop+=3;
  444.   if (entry_count == entries) {
  445.     fprintf(stderr,
  446.         "\nINITERROR: more module functions that declared in '%s'\n",
  447.         current_open_module->name->SYMBOL.pname);
  448.     exit(1);
  449.   }
  450.  
  451.   sym = get_symbol(stacktop,name);
  452.   ARG_2(stackbase)=sym;
  453.   ARG_0(stackbase) = current_open_module->values[entry_count] =
  454.     allocate_instance(stacktop,Generic);
  455.  
  456.   (current_open_module->functions)[entry_count] = NULL;
  457.   
  458.   lval_typeof(ARG_0(stackbase))=TYPE_GENERIC;
  459.   generic_home(ARG_0(stackbase)) = (LispObject)current_open_module;
  460.   tmp = allocate_integer(stacktop,code);
  461.   generic_argtype(ARG_0(stackbase)) =tmp;
  462.   generic_name(ARG_0(stackbase)) = ARG_2(stackbase);
  463.   
  464.   generic_fast_method_cache(ARG_0(stackbase)) = nil;
  465.   generic_slow_method_cache(ARG_0(stackbase)) = nil;
  466.   ARG_1(stackbase)=allocate_integer(stacktop,entry_count);
  467.  
  468.   generic_method_table(ARG_0(stackbase)) = nil;
  469.   generic_method_class(ARG_0(stackbase)) = Method;
  470.  
  471.   generic_discriminator(ARG_0(stackbase)) = nil;
  472.  
  473.   ADD_BINDING(current_open_module,ARG_2(stackbase),ARG_1(stackbase),nil);
  474.  
  475.   /* Symbols can't be GC'd and modules are safe anyway!! */
  476.  
  477.   tmp =
  478.     EUCALL_2(Fn_cons,ARG_2(stackbase),current_open_module->exported_names);
  479.   current_open_module->exported_names = tmp;
  480.   (current_open_module->functions)[entry_count] = fun;
  481.  
  482.   if (CREATE_INTERFACE) update_interface(name,entry_count,code);
  483.   ++entry_count;
  484.  
  485.   return(ARG_0(stackbase));
  486. }
  487.  
  488.  
  489. /*
  490.  
  491.  * Environment functions...
  492.  
  493.  */
  494.  
  495. LispObject make_anonymous_module_env_function_1(LispObject *stacktop,
  496.                         LispObject mod,
  497.                         LispObject (*fun)(LispObject*),
  498.                         int argtype,
  499.                         LispObject sym,
  500.                         LispObject val)
  501. {
  502.   LispObject lfunc;
  503.   LispObject env;
  504.  
  505.   STACK_TMP(sym); STACK_TMP(val);
  506.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  507.   UNSTACK_TMP(val); UNSTACK_TMP(sym);
  508.   STACK_TMP(lfunc);
  509.   /* Rig the environment... */
  510.  
  511.   env = allocate_env(stacktop,sym,val,NULL);
  512.   UNSTACK_TMP(lfunc);
  513.   lfunc->C_FUNCTION.env = &env->ENV;
  514.  
  515.   return(lfunc);
  516. }
  517.  
  518. LispObject make_anonymous_module_env_function_2(LispObject *stacktop,
  519.                         LispObject mod,
  520.                         LispObject (*fun)(LispObject*),
  521.                         int argtype,
  522.                         LispObject sym1,
  523.                         LispObject val1,
  524.                         LispObject sym2,
  525.                         LispObject val2)
  526. {
  527.   LispObject lfunc;
  528.   LispObject env;
  529.   STACK_TMP(sym2); STACK_TMP(val2);
  530.   STACK_TMP(sym1); STACK_TMP(val1);
  531.   lfunc = allocate_module_function(stacktop,mod,nil,fun,argtype); /* GC Safe */
  532.   
  533.   /* Rig the environment... */
  534.   UNSTACK_TMP(val1); UNSTACK_TMP(sym1); STACK_TMP(lfunc);
  535.   env = allocate_env(stacktop,sym1,val1,NULL);
  536.   UNSTACK_TMP(lfunc);
  537.   UNSTACK_TMP(val2); UNSTACK_TMP(sym2); STACK_TMP(lfunc);
  538.   env = allocate_env(stacktop,sym2,val2,env);
  539.   UNSTACK_TMP(lfunc);
  540.   lfunc->C_FUNCTION.env = (Env)env;
  541.  
  542.   return(lfunc);
  543. }
  544.  
  545.